; $Id: th.scm,v 1.9 2000/02/28 10:08:58 davidp Exp $

; A repository for utilities implementing test harness facilities
; that are commonly used but which are rather clumsy to do in the
; toolkit itself. Would folks please add any more that they think are
; needed.
;
; Currently this file contains the following utilities:
;
; draw - display only a single or several bodies
; debug - debug the size of a body, or debug the whole to a file
; edgeprop - debug and calculate properties of an edge
; faceprop - debug and calculate properties of a face
; view-init - display bodies in a sensible default view
; count - count numbers of entities in a body
; th:section - section a body at given z value
; opt - query, set or list options
; quit, q - to leave image
; red, green, blue... - colours defined as lowercase
; load patch - add path of loaded Scheme file to part-load-path
; block - briefer more test harness-like syntax for making a block
; wiggle - ditto, for a wiggle
; error message patch - include identifier like the test harness does
; move, rot - to move/rotate bodies conveniently
; cyl - to make a cylinder
; last-ent, name - for when you forget to name what you just made
; inc - allows files to take input from console (with error handling)
; set-ray, auto-set-ray - set pick raysize (automatically) to a useful value
; now - to name a state
; dotimes - macro for repeating forms (nothing to do with test harness!)
; map-edge - macro for stepping along an edge
; ret - retrieve bodies and name them a, a1, a2 etc. as per test harness
; top-face, bottom-face etc. - return top/bottom etc. face of a body
;
; Initial author: DAP

(provide 'th)


;---------------------------------------------------------------
; Test harness: draw <bodies...>
; Scheme: (draw <bodies...>)
; If no bodies listed, draw the lot.

(define (draw . ents)
  (map entity:erase (if (null? ents) '() (part:entities)))
  (map entity:display (if (null? ents) (part:entities) ents)))


;---------------------------------------------------------------
; Test harness: debug <body> to <file>  OR  debug <body> size
; Scheme: (debug <body> <file>)  OR  (debug <body> 'size)

(define (debug ent . file-or-size)
  (let ((level (if (eq? (car file-or-size) 'size) 3 4))
	(file (if (eq? (car file-or-size) 'size) '() (car file-or-size))))
    (if (not (null? file)) (debug:file file))
    (entity:debug ent level)
    (if (not (null? file)) (debug:file))))


;---------------------------------------------------------------
; Testharness: edgeprop <body> gpick [ at <param> ]
; Scheme: (edgeprop (pick-edge) [ param ])
; Output is somewhat different in format, but the content
; should be mostly all there.

(define (edgeprop edge . param)
  (let ((startp (curve:start-param edge))
	(endp (curve:end-param edge)))
    (if (null? param)
	(let ((midp (/ (+ startp endp) 2)))
	  (entity:debug edge 2)
	  (format #t "\nConvexity: ~s\n" (edge:ed-cvty-info edge))
	  (let ((midc (edge:pt-cvty-info edge midp)))
	    (format #t "Convexity at mid: ~s\n" midc)
	    (format #t "                  (resolves to: ~s)\n"
		    (pt-cvty-info:instantiate midc -1)))
	  (format #t "\nStart param: ~s\n" (curve:start-param edge))
	  (format #t "Start pos: ~s\n" (curve:start-pos edge))
	  (format #t "Start tan: ~s\n" (curve:start-tan edge))
	  (format #t "\nEnd param: ~s\n" (curve:end-param edge))
	  (format #t "End pos: ~s\n" (curve:end-pos edge))
	  (format #t "End tan: ~s\n" (curve:end-tan edge)))
	(let ((param (car param)))
	  (let ((ratiop (/ (- param startp) (- endp startp))))
	    (format #t "At parameter ~s\n" param)
	    (let ((c (edge:pt-cvty-info edge param)))
	      (format #t "Convexity: ~s\n" c)
	      (format #t "           (resolves to: ~s)\n"
		      (pt-cvty-info:instantiate c -1)))
	    (format #t "Pos: ~s\n" (curve:eval-pos edge ratiop))
	    (format #t "Tan: ~s\n" (curve:eval-tan edge ratiop)))))))


;---------------------------------------------------------------
; Testharness: faceprop <body> gpick
; Scheme: (faceprop (pick-face))
; Again, not quite the same, but close enough.

(define (faceprop f)
  (entity:debug f 2)
  (format #t "\n")
  (let ((n 0))
    (map (lambda (l) (set! n (+ 1 n))
		 (format #t "Loop ~s has ~s coedges\n" n (length (entity:coedges l))))
	 (entity:loops f)))
  (format #t "\n")
  (map (lambda (p) (format #t "~a: \t~s\n" (car p) (cdr p))) (face:prop f))
  '())


;---------------------------------------------------------------
; Testharness: view init
; Scheme: (view-init)
; Actually behaviour is different in Scheme, and I think more
; useful - it gives a standard isometric view in which the bodies fill
; the window. Also makes a view if none yet exist, and does a rebuild
; to ensure curves look reasonably curved.

(define (view-init)
  (if (null? (env:views)) (view:dl))
  (iso)
  (zoom-all)
  (render:rebuild))


;---------------------------------------------------------------
; Testharness: assert <body> faces 6 edges 12 [..]
; Scheme: (count <body> faces 6 edges 12 [..] )
; The "count" macro is a self-extending facility. You can "count"
; any "thing" for which an entity:things function exists. The first
; argument does not need to be a body (unless the entity:things
; functions require it).

(require 'count "count.scm")


;---------------------------------------------------------------
; Testharness: section <body> at <height>
; Scheme: (th:section <height> [ <body> .. ] )
; A list of bodies may be given, or if none, *all* bodies are
; sectioned. Sections get coloured red.

(define (th:section height . bodies)
  (if (null? bodies) (set! bodies (part:entities)))
  (do ((left bodies (cdr left))) ((null? left))
    (if (and (null? (entity:wires (car left)))
	     (not (null? (entity:lumps (car left)))))
	(let ((slice (solid:planar-slice (car left) (position 0 0 height) (gvector 0 0 1))))
	  (entity:set-color slice 1)))))


;---------------------------------------------------------------
; Testharness: opt ? | <optname> [ <val> [ <optname2> <val2> .. ] ]
; Scheme: (opt [ <optname> [ <val> [ <optname2> <val2> .. ] ] ])
; <val> may be given as on or off. If no args given, lists all options.

(define (every-other lst)
  (if (null? lst) '() (cons (car lst) (every-other (cddr lst)))))

(define (opt . args)
  (if (null? args)
      (let ((nopts 0))
	(map (lambda (i) (set! nopts (+ 1 nopts))
		     (format #t "~a:\t~s\n" (car i) (cdr i)))
	     (option:list))
	nopts)
      (if (null? (cdr args)) (option:get (car args))
	  (map option:set (every-other args) (every-other (cdr args))))))
(define on #t)
(define off #f)


;---------------------------------------------------------------
; Testharness: quit  OR  q
; Scheme: (quit)  OR  (q)

(define quit exit)
(define q exit)


;---------------------------------------------------------------
; In the test harness colour names can be given in lowercase.

(define blue BLUE)
(define red RED)
(define cyan CYAN)
(define black BLACK)
(define magenta MAGENTA)
(define yellow YELLOW)
(define white WHITE)
(define green GREEN)


;---------------------------------------------------------------
; The following kludges make Scheme behave like the test harness as
; regards loading parts, in the sense that it will look in the
; directory of the scm file being loaded first for the part in
; question. Use (enable-load-with-path #f) to disable this facility.

; Return cons of pathname bit of filename (or #f if none) and the name
; bit.
(define (pathname filename)
  (if (not (string? filename)) (set! filename (format #f "~a" filename)))
  (let ((len (string-length filename)))
    (do ((i (- len 1) (- i 1))
	 (pathname (cons #f filename)))
	((or (car pathname) (< i 0)) pathname)
      (let ((char (string-ref filename i)))
	(if (or (char=? #\/ char) (char=? #\\ char))
	    (set! pathname
		  (cons (substring filename 0 i)
			(substring filename (+ i 1) len))))))))

; Handy macro for errors. Execute body and if no errors occur return
; the value of the final form. If an error occurs, execute and return
; the error-value form, and then *carry on*. Results undefined if
; there's an error in the error-value form, so keep it simple! Also, I
; get same strange problems using fluid-let, so have avoided it.
(define-macro (continue-if-error error-value . body)
  `(call-with-current-continuation
    (lambda (catch)
      (let ((old-error-handler error-handler))
	(set! error-handler
	      (lambda msg
		(set! error-handler old-error-handler)
		(format #t "~a~a~%" "*** Error " (error-string msg))
		(catch ,error-value)))
	(let ((result (begin ,@body)))
	  (set! error-handler old-error-handler)
	  result)))))

(define-macro (push val lst) `(set! ,lst (cons ,val ,lst)))
(define-macro (pop lst) `(set! ,lst (cdr ,lst)))

; This is the new version of load which wraps the pathname of the file
; being loaded round the real load operation. We just load into the
; top-level-environment, for want of anything sneakier.
(define (load-with-path . args)
  (let ((p (car (pathname (car args)))))
    (if p (push p part-load-path))
    (continue-if-error (begin (if p (pop part-load-path)) #v)
     (if (null? (cdr args)) (set! args (list (car args) top-level-environment)))
     (let ((result (apply load-internal args)))
       (if p (pop part-load-path))
       result))))

(if (not (bound? 'load-internal)) (define load-internal load))

; Finally, to install the new function.
(define (enable-load-with-path onoff)
  (set! load (if onoff load-with-path load-internal)))

; By default we install it. Use (enable-load-with-path #f) to disable
; it.
(enable-load-with-path #t)


;---------------------------------------------------------------
; Test harness: block b w 60 d 60 h 60
; Scheme: (define b (block 60 60 60))   [just to save a bit of typing!]
; Order of Scheme argument is x y z, i.e. w, d, h.

(define (block x y z)
  (let ((x2 (/ x 2))
	(y2 (/ y 2))
	(z2 (/ z 2)))
    (solid:block (position (- x2) (- y2) (- z2)) (position x2 y2 z2))))


;---------------------------------------------------------------
; Test harness: wiggle b w 60 d 60 h 60
; Scheme: (define b (wiggle 60 60 60))   [just default to symmetric]
; Order of Scheme argument is x y z, i.e. w, d, h. Symmetric wiggle is
; made by default.

(define (wiggle x y z . rest)
  (if (null? rest) (set! rest (list "sym")))
  (apply solid:wiggle x y z rest))


;---------------------------------------------------------------
; Make error reports include the module and identifier code (like in
; the test harness). Set this option to #f to suppress this feature.

(opt "full_error_msg" on)


;---------------------------------------------------------------
; Test harness: move <body> by 30 0 30
; Scheme: (move <body> 30 0 30)
; <body> may actually be a list of bodies. If a null list, all bodies
; are moved.

(define (move bodies x y z)
  (if (not (list? bodies)) (set! bodies (list bodies)))
  (if (null? bodies) (set! bodies (part:entities)))
  (let ((trans (transform:translation (gvector x y z))))
    (map (lambda (ent)
	   (if (body? ent) (entity:transform ent trans)
	       (format #t "Entity ~a not a body" ent))) bodies)
    #v))

;---------------------------------------------------------------
; Test harness: rotate <body> by 30 about <axis>
; Scheme: (rot <body> 30 <axis> [<origin>])
; <body> may actually be a list of bodies, or null to mean all
; bodies. <axis> may be x, y or z, or a triple of numbers e.g.
; (rot b 30 1 1 1). <origin> may be omitted to mean (0,0,0).

(define (rot bodies angle . args)
  (if (not (list? bodies)) (set! bodies (list bodies)))
  (if (null? bodies) (set! bodies (part:entities)))
  (let ((axis)
	(origin (position 0 0 0)))
    (if (symbol? (car args))
	(begin (if (eq? (car args) 'x) (set! axis (gvector 1 0 0))
		   (if (eq? (car args) 'y) (set! axis (gvector 0 1 0))
		       (if (eq? (car args 'z) (set! axis (gvector 0 0 1))
				(error 'rot "Bad axis ~a" (car args))))))
	       (set! args (cdr args)))
	(begin (set! axis (gvector (car args) (cadr args) (caddr args)))
	       (set! args (cdddr args))))
    (if (not (null? args)) (set! origin (apply position args)))
    (let ((trans (transform:rotation origin axis angle)))
      (map (lambda (ent)
	     (if (body? ent) (entity:transform ent trans)
		 (format #t "Entity ~a not a body" ent))) bodies)
      #v)))


;---------------------------------------------------------------
; Test harness: cyl c r <r> h <h> ratio <ratio>
; Scheme: (cyl <r> <h> [ <ratio>=1 ])

(define (cyl r h . ratio)
  (if (null? ratio) (set! ratio 1) (set! ratio (car ratio)))
  (let ((z (/ h 2)))
    (solid:cylinder (position 0 0 (- z)) (position 0 0 z) r ratio)))


;---------------------------------------------------------------
; No test harness equivalent, but in Scheme it's easy to forget to
; name something you make. These make life easier.
; (last-ent)    return the last entity made
; (name b)      name the last thing made as b

(define (last-ent) (car (last-pair (part:entities))))
(define-macro (name n) `(define ,n (last-ent)))


;---------------------------------------------------------------
; Test harness: inc <filename> | con
; Scheme: (inc [ <filename> ])
; Omit the filename to read input from the console. Always searches
; for parts first in the directory of the "inc"ed file. Note that
; "inc"ing too many levels may run out of heap space - if so, restart
; the toolkit with the -h option followed by a large number (such as
; 1000 or 2000..., the current default is 512).

(define inc-level 0)
(define inc-abort #f)

(define (inc . filename)
  (let ((in (if (null? filename) #f (open-input-file (car filename))))
	(pname (if (null? filename) '(#f . "console") (pathname (car filename)))))
    (if (car pname) (push (car pname) part-load-path))
    (set! inc-level (+ inc-level 1))
    (set! inc-abort #f)
    (format #t "Input from ~a (level ~a), (ex) leaves 1 level, (aba) leaves all levels\n"
	    (cdr pname) inc-level)
    (let loop ()
      (if (not inc-abort)
	  (let ((expr (continue-if-error '(ex)
		       (format #t "~a:~a> " (cdr pname) inc-level)
		       (if in (read in) (read)))))
	    (if in (print expr))
	    (if (equal? expr '(aba))
		(begin (set! inc-abort #t)
		       (format #t "Leaving input, all levels\n"))
		(if (not (or (eof-object? expr) (equal? expr '(exit)) (equal? expr '(ex))))
		    (let ((result (continue-if-error #v
				   (eval expr top-level-environment))))
		      (if (not (eq? result #v)) (print result))
		      (loop))
		    (format #t "Leaving ~a input level ~a\n" (cdr pname) inc-level))))))
    (set! inc-level (- inc-level 1))
    (if (car pname) (pop part-load-path))
    (if in (close-input-port in))
    #v))


;---------------------------------------------------------------
; Test harness: opt viewspace_ray on [raysize <size>]
; Scheme: (set-ray [ <size>=1 ]), also (auto-set-ray #t)
; Call (set-ray) to set the raysize to a useful size of about
; default-ray-pixels (= 5) pixels in the current view. <size> may be
; passed to alter this proportionately. Use (auto-set-ray #t) to make
; the raysize be updated automatically each time the view is refreshed
; (pass #f to turn this feature off again).

(define default-ray-pixels 5)

(define (set-ray . args)
  (if (null? args) (set! args (list 1.0)))
  (if (null? (env:views)) (option:set "raysize" (car args))
      (let ((pixels-per-unit (/ (caddr (view:viewport))  (view:width)))
	    (wanted-pixels (* (car args) default-ray-pixels)))
	(option:set "raysize" (/ wanted-pixels pixels-per-unit)))))

(if (not (bound? 'view:refresh-internal))
    (define view:refresh-internal view:refresh))
    
(define (view:refresh-auto-set-ray . args)
  (let ((result (apply view:refresh-internal args)))
    (set-ray)
    result))

; Call this with #t so that the raysize gets updated automatically as
; the view is refreshed. We leave it off by default, however. Also,
; save the current raysize when turned on, so that it can be restored
; again when disabled.
(define auto-set-ray-previous 0)
(define (auto-set-ray onoff)
  (if onoff
      (begin (if (eq? view:refresh view:refresh-internal)
		 (set! auto-set-ray-previous (option:get "raysize")))
	     (set-ray)
	     (set! view:refresh view:refresh-auto-set-ray))
      (begin (if (eq? view:refresh view:refresh-auto-set-ray)
		 (option:set "raysize" (* 1.0 auto-set-ray-previous)))
	     (set! view:refresh view:refresh-internal))))


;---------------------------------------------------------------
; Test harness: now <name>
; Scheme: (now <name>)
; To name a state, with a bit less typing.

(define (now name)
  (roll:name-state name))


;---------------------------------------------------------------
; No test harness equivalent for this, but I find it jolly useful.
; Scheme: (dotimes <n> ..)  OR  (dotimes (<var> <n>) ..)
; Perform the contained forms <n> times. In the latter case the
; variable <var> counts from 0 to <n>-1 inclusive. Returns a list
; of each body evaluation so for example, to make a list of 5
; picked edges, use (dotimes 5 (pick-edge)).

(define-macro (dotimes count-spec . body)
  (let ((var (if (pair? count-spec) (car count-spec) 'tmp-symbol))
	(n (if (pair? count-spec) (cadr count-spec) count-spec)))
    `(let ((result (list #f)))
       (do ((,var 0 (+ ,var 1)) (end-val ,n) (end result (cdr end)))
	   ((= ,var end-val) (cdr result))
	 (set-cdr! end (list (begin ,@body)))))))

; And in case you want the last value of the list returned, e.g.
; (last (dotimes 3 (pick-edge)))

(define (last lst) (if (pair? (cdr lst)) (last (cdr lst)) (car lst)))


;---------------------------------------------------------------
; Also nothing to do with the test harness, but very handy.
; Scheme: (map-edge <edge> <num> ..)
; For the given edge execute the body <num> times, each iteration
; taking a further equal step down the edge. For the body evaluations
; i is bound as a loop counter (going from 0 to <num>-1 inclusive), t
; is bound to the parameter as we step along the edge, and r expresses
; as a ratio how far we are along the edge, from 0 to 1 inclusive
; (some Scheme extensions seem to want this value). An example:
; (map-edge my-edge 20 (print (edge:pt-cvty-info my-edge t)))
; prints the angle between faces at 20 points along the edge. Returns nil.

(define-macro (map-edge edge num . body)
  `(let* ((metmp-num (- ,num 1))
	  (metmp-edge ,edge)
	  (metmp-startp (curve:start-param metmp-edge))
	  (metmp-step (/ (- (curve:end-param metmp-edge) metmp-startp) metmp-num)))
     (do ((i 0 (+ 1 i)))
	 ((> i metmp-num))
       (let* ((t (+ metmp-startp (* i metmp-step)))
	      (r (/ i metmp-num)))
	 ,@body))))


;---------------------------------------------------------------
; In the same vein as the above:
; Scheme: (map-surface <surface-spec> <num_u> <num_v> ..), or
; Perform a double loop over the given surface executing the body of
; the macro. <surface-spec> may be either just a surface (in which
; case the surface ranges could be unbounded), or a list of a surface
; and 2 positions (to define a box to restrict the surface range), or
; a face (in which case the face box is used), or a list of a surface
; and two pairs, being the u and v ranges. During the loop, i
; counts the number of u loops, 0 <= i <= <num_u>-1, j the number of v
; loops. u and v are bound to the u and v parameters, and ur and vr
; give the u/v parameter ranges for the surface. Additionally, sf is
; bound to the surface. Examples:
; (map-surface (pick-face) 5 5 
;   (format #t "Pos at (~a,~a): ~a\n" u v (surface:eval-pos sf u v)))
; (map-surface (list my-srf '(0 . 1) '(0 . 1)) 10 10
;   (print (surface:eval-pos sf u v)))

; First a utility. Like destructuring-bind, define a simple
; "destructuring-match" facility. Any atoms in the list are taken
; to be predicate functions. #t acts as a wildcard. Examples:
; (destructuring-match (number? (number? symbol?)) '(1 (2 a)))  -> #t
; (destructuring-match (number? (number? symbol?)) '(1 (2 a) b))  -> #f
; (destructuring-match (number? list? . #t) '(1 (2 a) b))  -> #t
(define (safe-car arg) (if (pair? arg) (car arg) ':fail-safe))
(define (safe-cdr arg) (if (pair? arg) (cdr arg) ':fail-safe))
(define (check-fail-safe fn val) (if (eq? ':fail-safe val) #f (fn val)))
(define (destructure-matches pattern val)
  (if (pair? pattern)
      (append (destructure-matches (car pattern) `(safe-car ,val))
	      (destructure-matches (cdr pattern) `(safe-cdr ,val)))
      (if (eq? pattern #t) `((not (eq? ':fail-safe ,val)))
	  (if (null? pattern) `((null? ,val)) `((check-fail-safe ,pattern ,val))))))
(define-macro (destructuring-match pattern val)
  `(let ((tmp-symbol ,val))
     (and ,@(destructure-matches pattern 'tmp-symbol))))

; Utility for map-surface. Parses its first argument.
(define (sf-and-intervals sf-spec)
  (cond ((destructuring-match surface? sf-spec)
	 (cons sf-spec (surface:range sf-spec)))
	((destructuring-match face? sf-spec)
	 (let ((box (entity:box sf-spec))
		(sf (surface:from-face sf-spec)))
	    (cons sf (surface:range sf (car box) (cdr box)))))
	((destructuring-match (surface? position? position?) sf-spec)
	 (cons (car sf-spec) (apply surface:range (cdr sf-spec))))
	((destructuring-match (surface? (number? . number?) (number? . number?)) sf-spec)
	 sf-spec)
	(else (error 'map-surface "First argument not understood"))))

(define-macro (map-surface sf-spec num-u num-v . body)
  `(destructuring-bind (sf ur vr) (sf-and-intervals ,sf-spec)
     (if (or (not (car ur)) (not (cdr ur)) (not (car vr)) (not (cdr vr)))
	 (error 'map-surface "One or both surface ranges unbounded"))
     (if (or (> (car ur) (cdr ur)) (> (car vr) (cdr vr)))
	 (error 'map-surface "One or both surface ranges empty"))
     (let* ((mstmp-num-u (- ,num-u 1))
	    (mstmp-num-v (- ,num-v 1))
	    (mstmp-step-u (/ (- (cdr ur) (car ur)) mstmp-num-u))
	    (mstmp-step-v (/ (- (cdr vr) (car vr)) mstmp-num-v)))
       (do ((i 0 (+ 1 i)))
	   ((> i mstmp-num-u))
	 (let ((u (+ (car ur) (* i mstmp-step-u))))
	   (do ((j 0 (+ j 1)))
	       ((> j mstmp-num-v))
	     (let ((v (+ (car vr) (* j mstmp-step-v))))
	       ,@body)))))))


;---------------------------------------------------------------
; Test harness: ret foo.sat as a
; Scheme: (ret "foo.sat" a)
; Retrieves bodies from a sat file and, if more than one, names them
; a, a1, a2 etc. as the test harness would. This is a bit of a dirty
; hack as it calls eval and frigs the environment, but I'm not sure
; how else to do this (offers appreciated!).

(define-macro (ret fn var)
  `(let ((bodies (part:load ,fn))
	 (env (the-environment)))
     (eval `(define ,',var ,(car bodies)) env)
     (do ((rest (cdr bodies) (cdr rest))
	  (result (list ',var))
	  (i 1 (+ i 1)))
	 ((null? rest) (reverse! result))
       (let ((body (car rest))
	     (sym (string->symbol (format #f "~a~a" ',var i))))
	 (eval `(define ,sym ,body) env)
	 (set! result (cons sym result))))))


;---------------------------------------------------------------
; Test harness: top, bottom, left, right, front, back
; Scheme: (top-face b)
; Returns the top/bottom etc. face of the body b in the same way that
; a number of test harness commands accept as part of their syntax.

(define (top-face body) (body:find-face body (gvector 0 0 1)))
(define (bottom-face body) (body:find-face body (gvector 0 0 -1)))
(define (right-face body) (body:find-face body (gvector 0 1 0)))
(define (left-face body) (body:find-face body (gvector 0 -1 0)))
(define (front-face body) (body:find-face body (gvector 1 0 0)))
(define (back-face body) (body:find-face body (gvector -1 0 0)))
